Celestin Apprentice 2/Apprentice-Release2.iso/Source Code/Pascal/System/WackyPointer INIT/WackyPInit.p

Text File | 1994-11-20 | 7.3 KB | 274 lines | [TEXT/PJMM]

unit WackyPointerInit;
{  Written by Brian Stern July 1993, updated Nov., 1994 }
{  Copyright 1993 Aster Software Inc. }
{  All rights reserved. }
{  The WackyPointer Init is a silly little thing written as }
{  an exercise in Init writing and to learn how to use the }
{  jGNEFilter and VBLTasks.  When installed on a machine }
{  any mousedown causes the curser to spin around.  It stops }
{  on mouseup (usually). }

interface

    uses
        Retrace, SysEQu;

    procedure main;

implementation

    const
        ToolScratch = $9CE;
        acurID = 4444;
        kDesiredCount = 3;

    type
        pToPtr = ^Ptr;
        pToProcPtr = ^ProcPtr;
        EventPtr = ^EventRecord;
        CursHand = ^CursPtr;

        eachCursor = record
                case integer of
                    1: (
                            cursNum: integer;
                            Spare: integer;
                    );
                    2: (
                            theCurHand: CursHand;
                    );
            end;

        acur = record
                numFrames: integer;
                FrameCounter: integer;
                ID: array[0..20] of eachCursor;
            end;
        acurPtr = ^acur;
        acurHand = ^acurPtr;

        TaskBlock = record
                theRecord: VBLTask;
                theacurHand: acurHand;
                Installed: Boolean;
            end;
        TBPtr = ^TaskBlock;

        IntPtr = ^integer;
        LongIntPtr = ^Longint;

        Mess = record           {allow access to single bytes in event message}
                case Integer of
                    1: (
                            themsg: longint
                    );
                    2: (
                            mess1, mess2: SignedByte;
                            mess3: Integer
                    );
            end;     {Mess}
        PToMess = ^Mess;

    var
        gOldGNEFilter: ProcPtr;
        gTaskBlockPtr: TBPtr;
        gCurHand: acurHand;
        gError: OSErr;

{*****InstallVBLTask************************************************}

    procedure InstallVBLTask;
{  This proc sets a few fields in the VBLTask rec and installs it.}
{  Some apps mask out mouse ups or for some reason they are lost}
{  So always check if the task is already installed before installing it.}
{  It crashes if installed twice.}
    begin
        if gTaskBlockPtr^.Installed = False then
            begin
                with gTaskBlockPtr^, theRecord do
                    begin
                        vblCount := kDesiredCount;
                        vblPhase := 0;
                        if noErr = VInstall(QElemPtr(gTaskBlockPtr)) then
                            Installed := True;
                    end;
            end;
    end;

{*****RemoveVBLTask************************************************}

    procedure RemoveVBLTask;
{Remove the VBLTask from the queue}
    begin
        if gTaskBlockPtr^.Installed = True then
            begin
                if noErr = VRemove(QElemPtr(gTaskBlockPtr)) then
                    gTaskBlockPtr^.Installed := False;
            end;
    end;

{*****GetVBLPtr************************************************}

    function GetVBLPtr: TBPtr;
{Courtesy of Grobbins}
    inline
        $2E88;    {Move.L A0, (A7)   Put A0 on the stack}


{*****TheTask************************************************}

    procedure TheTask;
{  This is the VBLTask.  It simply spins the cursor and resets itself}
        var
            TaskBlockPtr: TBPtr;

    begin
        TaskBlockPtr := GetVBLPtr;
        with TaskBlockPtr^, theacurHand^^ do
            begin
                if IntPtr(CrsrBusy)^ = 0 then
                    begin
                        frameCounter := (frameCounter + 1) mod numFrames;
                        SetCursor(ID[frameCounter].theCurHand^^);    {Spin the cursor}
                    end;
                TaskBlockPtr^.theRecord.vblCount := kDesiredCount;        {Reset the vbltask counter}
            end;
    end;

{*****SetUpVBLTask************************************************}

    function SetUpVBLTask: integer;
{This function allocates space for a VBLTask record and fills}
{in the fields but it doesn't install it.  The record is }
{installed and removed from the jGNEFilter}
    begin
        gTaskBlockPtr := TBPtr(NewPtrSys(Sizeof(TaskBlock)));    {Allocate space in sys Heap}
        if gTaskBlockPtr <> nil then
            with gTaskBlockPtr^, theRecord do        {Fill in the fields in the record}
                begin
                    qType := ord(vType);
                    vblAddr := @TheTask;
                    vblCount := kDesiredCount;
                    vblPhase := 0;
                    theacurHand := gCurHand;
                    Installed := False;
                    SetUpVBLTask := NoErr;
                end
        else
            SetUpVBLTask := -1;        {An error occurred}
    end;

{*****UnlinkAndJumpToOldFilter************************************************}

    procedure UnlinkAndJumpToOldFilter (theFilterProc: ProcPtr);
{Move the procptr to the stack and JMP to it }
    inline
        $205F,                {MoveA.L  (A7)+, A0 }
        $4CDF, $0C80,         {MoveM.L (A7)+, D7/A2/A3}
        $4E5E,                {Unlk  A6}
        $4ED0;                {JMP(A0)}

{*****GetD0************************************************}

    function GetD0: longint;
    inline
        $2E80;        {Move.L  D0, (A7)}

{*****SetD0************************************************}

    procedure SetD0 (theValue: longint);
    inline
        $201F;        {Move.L    ( A7 )+, D0}

{*****GetEventPtr************************************************}

    function GetEventPtr: EventPtr;
    inline
        $2E89;        {Move.L   A1, (A7)}

{*****FilterProc************************************************}

    procedure FilterProc;
{This is the jGNEFilter.  It simply checks for mousdowns}
{and mouseups and installs or removes the vbltask.}
{When switching from one app to another there doesn't}
{seem to be a mouseup event to match the mousedown.}
{We could use the process manager to keep track of the current}
{process and then Remove the VBL task if the process changed.}
        var
            theEvent: EventPtr;
            oldProc: ProcPtr;
            saveD0: longint;
    begin
        SetUpA4;                        {Restore A4 to allow access to globals}
        saveD0 := GetD0;            {Save the contents of D0, the function result}
        theEvent := GetEventPtr;    {Get ptr to eventrecord from A1}
        if theEvent^.what = MouseDown then
            InstallVBLTask                {Install VBLTask if mousedown}
        else if theEvent^.what = MouseUp then
            RemoveVBLTask;            {Remove the VBLTask if a mouseup}
        oldProc := gOldGNEFilter;    {Save the address of the previous jGNEFilter in a local variable}
        SetD0(saveD0);                {Restore the contents of D0}
        RestoreA4;
        UnlinkAndJumpToOldFilter(oldProc);        {Execute the previous jGNEFilter}
    end;

{*****InstallFilter************************************************}

    procedure InstallFilter;
{Save the ProcPtr to the previous jGNEFilter and insert ours}
    begin
        gOldGNEFilter := pToProcPtr(jGNEFilter)^;                                    {Save old Filter proc ptr}
        pToProcPtr(jGNEFilter)^ := ProcPtr(StripAddress(@FilterProc));        {Install new filter proc}
    end;

{*****GetTheResources************************************************}

    function GetTheResources: Integer;
{Read in the acur resource and the CURS resources}
{All must be marked sysheap and locked}
        var
            tempHand: Handle;
            i: integer;
    begin
        gCurHand := acurHand(GetResource('acur', acurID));            {Read the acur resource}
        if gCurHand = nil then
            begin
                GetTheResources := -1;
                Exit(GetTheResources);
            end;
        DetachResource(Handle(gCurHand));
        with gCurHand^^ do
            for i := 0 to numFrames - 1 do
                begin
                    tempHand := GetResource('CURS', ID[i].cursNum);        {Read in the Cursors}
                    if tempHand = nil then
                        begin
                            GetTheResources := -1;
                            Exit(GetTheResources);
                        end;
                    DetachResource(tempHand);
                    Handle(ID[i]) := tempHand;
                end;
        gCurHand^^.frameCounter := 0;
        GetTheResources := NoErr;
    end;

{*****Main****************************************************}

    procedure Main;
        var
            MyHandle: Handle;
    begin
        RememberA4;        {Allows use of globals in the init}
        SetUpA4;
        InstallFilter;            {Install the jGNEFilter}
        if (GetTheResources = NoErr) & (SetUpVBLTask = NoErr) then
            begin            {Only get to here if no errors in getting resources and setting up VBLTask}
                MyHandle := RecoverHandle(pToPtr(ToolScratch)^);{Pascal puts the address of the init in ToolScratch}
                DetachResource(MyHandle);        {Detach the resource to remain in memory}
            end;
        RestoreA4;
    end;

end.